home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1997 September / Macworld (1997-09).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Menus / ftpMenu.tcl < prev    next >
Encoding:
Text File  |  1997-04-24  |  10.8 KB  |  445 lines  |  [TEXT/ALFA]
  1.  
  2. if $startingUp {
  3.     set ftpMenu            "•141"
  4.     addMenu ftpMenu
  5.     return
  6. }
  7.  
  8.  
  9.  
  10. proc ftpMenu {} {}
  11.  
  12.  
  13. if {![info exists savePostHooks] || ![string match {*ftpPostHook*} $savePostHooks]} {
  14.     lappend savePostHooks ftpPostHook
  15. }
  16.  
  17.  
  18. proc ftpPostHook {name} {
  19.     global fetched
  20.     if {[info exists fetched($name)]} {
  21.         set specs $fetched($name)
  22.         message "Updating '[file tail $name]' on [car $specs]…"
  23.         if {[string length [cadr $specs]]} {
  24.             ftpStore $name [car $specs] "[cadr $specs]/[file tail $name]" [caddr $specs] [cadddr $specs]
  25.         } else {
  26.             ftpStore $name [car $specs] "[file tail $name]" [caddr $specs] [cadddr $specs]
  27.         }
  28.     }
  29. }
  30.  
  31.  
  32. #         createFileSet
  33. proc rebuildFtpMenu {} {
  34.     global savedMounts recentMounts ftpMenu useCache
  35.     
  36.     menu -n $ftpMenu -p ftpMenuProc {
  37.         help
  38.         "(-"
  39.         "<S/ibrowse…"
  40.         "<S/i<IbrowseCurrent…"
  41.         "/nbrowseMounts…"
  42.         "saveAsAt…"
  43.         "(-"
  44.         addMountPoint…
  45.         makePermanent…
  46.         removeMountPoint…
  47.         saveAsAt…
  48.         "(-"
  49.         useCache
  50.         flushCache
  51.         "(-"
  52.         "createFileset"
  53.         "(-"
  54.     }
  55.     markMenuItem -m $ftpMenu "Use Cache" $useCache
  56.     if {[info exists savedMounts]} {
  57.         foreach m [lsort -ignore [array names savedMounts]] {
  58.             addMenuItem -m -l "b " $ftpMenu $m
  59.         }
  60.     }
  61.     if {[info exists recentMounts]} {
  62.         addMenuItem -m $ftpMenu "(-"
  63.         foreach m [lsort -ignore [array names recentMounts]] {
  64.             addMenuItem -m -l "b " $ftpMenu $m
  65.         }
  66.     }
  67. }
  68.  
  69. if {![info exists useCache]} {set useCache 1}
  70.  
  71. rebuildFtpMenu
  72.  
  73. insertMenu $ftpMenu
  74.  
  75. proc mountPoints {} {
  76.     global savedMounts recentMounts
  77.     if {[info exists recentMounts]} {
  78.         if {[info exists savedMounts]} {
  79.             set l [concat [array names recentMounts] [array names savedMounts]]
  80.         } else {
  81.             set l [array names recentMounts]]
  82.         }
  83.     } else {
  84.         set l [array names savedMounts]
  85.     }
  86.     return [lsort $l]
  87. }
  88.  
  89.  
  90.  
  91. proc ftpMenuProc {menu item} {
  92.     global modifiedVars modifiedArrVars savedMounts recentMounts PREFS fetched HOME ftpMenu useCache createFtpType
  93.     switch $item {
  94.         help                {editMark "$HOME:Help:Manual" "Ftp Browser" -r}
  95.         browse                {eval ftpBrowse [lrange [getLogin {Browse remote machine:} 0] 0 3]}
  96.         browseCurrent        { if {[info exists fetched([car [winNames -f]])]} {
  97.                                 eval ftpBrowse $fetched([car [winNames -f]]) 
  98.                             } else {
  99.                                 beep; message "'[car [winNames]]' not from remote host."
  100.                             }}
  101.         browseMounts        {
  102.             set l [mountPoints]
  103.             set res [listpick -p "Mount point:" $l]
  104.             if {[info exists recentMounts($res)]} {
  105.                 eval ftpBrowse $recentMounts($res)
  106.             } else {
  107.                 eval ftpBrowse $savedMounts($res)
  108.             }
  109.         }
  110.  
  111.         addMountPoint        { addMountPoint }
  112.         makePermanent        { makeMountPermanent }
  113.         createFileset        { ftpCreateFileset }
  114.         removeMountPoint    {
  115.             set pt [listpick -p "Remove which mount point?" [lsort -ignore [array names savedMounts]]]
  116.             unset savedMounts($pt)
  117.             removeArrDef savedMounts $pt
  118.             rebuildFtpMenu
  119.         }
  120.         saveAsAt            {
  121.             global fetched PREFS
  122.             set name [prompt "Name:" [car [winNames]]]
  123.             set point [listpick -p "At which mount point?" [mountPoints]]
  124.             if {[info exists recentMounts($point)]} {
  125.                 set specs $recentMounts($point)
  126.             } else {
  127.                 set specs $savedMounts($point)
  128.             }
  129.             set name "$PREFS:ftptmp:$name"
  130.             set fetched($name) $specs
  131.             message "Saving '$name' on [car $specs]…"
  132.             
  133.             cp "$HOME:Tcl:SystemCode:AlphaBits.tcl" $name
  134.             saveAs -f "$name"
  135.             
  136.             set num 0
  137.             set pathname [cadr $specs]
  138.             for {set i [expr [string length $pathname] - 1]} {$i >= 0} {incr i -1} {
  139.                 scan $pathname "%c" char
  140.                 incr num $char
  141.             }
  142.             
  143.             set nm "$PREFS:ftptmp:listing.$num"
  144.             catch {rm $nm}
  145.             
  146.             setWinInfo platform $createFtpType
  147.             setWinInfo dirty 1
  148.             save
  149.         }
  150.         
  151.         setDefaults            { 
  152.             global ftpDefaults modifiedVars
  153.             set ftpDefaults [lrange [getLogin "Enter defaults that you wish saved:" 0] 0 3]
  154.             lappend modifiedVars ftpDefaults
  155.         }
  156.         flushCache        { rm "$PREFS:ftptmp:*"; [catch {unset recentMounts}]; rebuildFtpMenu }
  157.         useCache    { 
  158.             set useCache [expr 1 - $useCache]
  159.             markMenuItem -m $ftpMenu "Use Cache" $useCache
  160.             lappend modifiedVars useCache
  161.         }
  162.         default {
  163.             if {[info exists recentMounts($item)]} {
  164.                 eval ftpBrowse $recentMounts($item)
  165.             } else {
  166.                 eval ftpBrowse $savedMounts($item)
  167.             }
  168.         }
  169.     }
  170. }
  171.  
  172.  
  173. proc ftpFilesetOpen {menu item} {
  174.     global gfileSets PREFS fetched fileSetsExtra
  175.     
  176.     if {[set ind [lsearch $gfileSets($menu) "*$item"]] >= 0} {
  177.         set f [lindex $gfileSets($menu) $ind]
  178.         set lnm [file tail $f]
  179.         regsub -all {:} $f {/} f
  180.         set nm "$PREFS:ftptmp:$lnm"
  181.         set specs $fileSetsExtra($menu)
  182.         if {![file exists $nm]} {
  183.             ftpFetch $nm [car $specs] $f [caddr $specs] [cadddr $specs]
  184.         }
  185.         edit -w $nm
  186.         set fetched($nm) $specs
  187.     }
  188. }
  189.  
  190.  
  191. proc ftpCreateFileset {} {
  192.     global gfileSets gfileSetsType PREFS fileSetsExtra
  193.     
  194.     set specs [getLogin]
  195.     set name [car $specs]
  196.     set host [cadr $specs]
  197.     set path [caddr $specs]
  198.     set user [cadddr $specs]
  199.     set password [caddddr $specs]
  200.     set pattern "^[prompt {Name pattern?} {.*.[ch]}]$"
  201.     set path [string trimright $path {/}]
  202.  
  203.     set fileSetsExtra($name) [list $host $path $user $password]
  204.     
  205.     if { ![file exists "$PREFS:ftptmp:"] } {
  206.         mkdir "$PREFS:ftptmp:"
  207.     }
  208.     set nm "$PREFS:ftptmp:listing.$path"
  209.     ftpList $nm $host $path $user $password
  210.     set files {}
  211.     foreach f [processListing $nm] {
  212.         if {![string match {*/} $f] && [regexp $pattern $f]} {
  213.             lappend files "$path/$f"
  214.         }
  215.     }
  216.     regsub -all {/} $files {:} files
  217.  
  218.     global gfileSets gfileSetsType
  219.     set gfileSets($name) [lsort -command sortByTail $files]
  220.     set gfileSetsType($name) ftp
  221.     if {[askyesno "Save project fileset?"] == "yes"} {
  222.         addArrDef gfileSetsType $name ftp
  223.         addArrDef gfileSets $name  $gfileSets($name)
  224.         addArrDef fileSetsExtra $name $fileSetsExtra($name)
  225.     }
  226.     return $name
  227. }
  228.  
  229.  
  230. proc getLogin {{prompt {All but 'password' are required:}} {nm 1}} {
  231.     global ftpDefaults
  232.     if {[info exists ftpDefaults]} {
  233.         set defs $ftpDefaults
  234.     } else {
  235.         set defs {"" "" "" ""}
  236.     }
  237.     set left 10
  238.     set right 100
  239.     set top 10
  240.     set bottom 30
  241.     set eleft [expr $left + 100]
  242.     set eright 370
  243.     set incr 30
  244.  
  245.     set height 198
  246.     
  247.     if $nm {incr height $incr}
  248.     set l "dialog -w 400 -h $height -t [list $prompt] $left $top 400 $bottom"
  249.     
  250.     if {$nm} {
  251.         incr top $incr
  252.         incr bottom $incr
  253.         lappend l -t {Name:} $left $top $right $bottom
  254.         lappend l -e {} $eleft $top $eright $bottom
  255.     }
  256.     
  257.     incr top $incr
  258.     incr bottom $incr
  259.     lappend l -t {Host:} $left $top $right $bottom
  260.     lappend l -e [car $defs] $eleft $top $eright $bottom
  261.     
  262.     incr top $incr
  263.     incr bottom $incr
  264.     lappend l -t {Path:} $left $top $right $bottom
  265.     lappend l -e [cadr $defs] $eleft $top $eright $bottom
  266.     
  267.     incr top $incr
  268.     incr bottom $incr
  269.     lappend l -t {UserID:} $left $top $right $bottom
  270.     lappend l -e [caddr $defs] $eleft $top $eright $bottom
  271.     
  272.     incr top $incr
  273.     incr bottom $incr
  274.     lappend l -t {Password:} $left $top $right $bottom
  275.     lappend l -e [cadddr $defs] $eleft $top $eright $bottom
  276.     
  277.     incr top [expr $incr + 10]
  278.     incr bottom [expr $incr + 10]
  279.     lappend l -b "OK" $left $top $right [expr $top + 20]
  280.     lappend l -b "Cancel" [expr $left + 200] $top [expr $right + 200] [expr $top + 20]
  281.     
  282.     set res [eval "$l"]
  283.     if {[lindex $res end]} {error "Cancel"}
  284.     return $res
  285. }
  286.  
  287.  
  288. proc addMountPoint {} {
  289.     global savedMounts modifiedArrVars
  290.     
  291.     set res [getLogin]
  292.     if {[lindex $res 5]} {
  293.         set savedMounts([car $res]) [lrange $res 1 4]
  294.         lappend modifiedArrVars savedMounts
  295.         rebuildFtpMenu
  296.     }
  297. }
  298.  
  299.  
  300. proc makeMountPermanent {} {
  301.     global recentMounts savedMounts modifiedArrVars
  302.     if {![info exists recentMounts]} {
  303.         alertnote "You have no temporary mounts."
  304.         return
  305.     }
  306.     set res [listpick -p "Make which temporary mount point permanent?" [lsort [array names recentMounts]]]
  307.     set name [prompt "Name?" $res]
  308.     set savedMounts($name) $recentMounts($res)
  309.     unset recentMounts($res)
  310.     lappend modifiedArrVars savedMounts
  311.     rebuildFtpMenu
  312. }
  313.  
  314.  
  315. proc ftpFetch {localName host path user password} {
  316.     global ftpSig
  317.     watchCursor
  318.     launchBackApplSigs [list Arch] ftpSig
  319.     set fd [open $localName "w"]
  320.     close $fd
  321.     AEBuild -r -t 30000 'Arch' Arch Ftch FTPh "“$host”" FTPc "“$path”" ArGU "“$user”" ArGp "“$password”" ---- [makeAlis $localName]
  322. }
  323.  
  324. proc ftpStore {localName host path user password} {
  325.     watchCursor
  326.     AEBuild -q -t 30000 'Arch' Arch Stor ---- [makeAlis $localName] FTPh "“$host”" FTPc "“$path”" ArGU "“$user”" ArGp "“$password”"
  327. }
  328.  
  329. proc handleReply {rep} {
  330.     global ALPHA lastReply
  331.     message "Remote save finished."
  332.     set lastReply $rep
  333. }
  334.  
  335. # 'localName' must be a preexisting file, this is a makeAlis limitation
  336. proc ftpList {localName host path user password} {
  337.     global ftpSig
  338.     watchCursor
  339.     launchBackApplSigs [list Arch] ftpSig "Please locate ftp app (such as 'anarchy'):"
  340.     set fd [open $localName "w"]
  341.     close $fd
  342.     AEBuild -r -t 30000 '$ftpSig' Arch List FTPh "“$host”" FTPc "“$path”" ArGU "“$user”" ArGp "“$password”" {----} [makeAlis $localName]
  343. }
  344.  
  345.  
  346. proc processListing {path} {
  347.     set fd [open $path "r"]
  348.     set lines [split [read $fd] "\n"]
  349.     close $fd
  350.     set files {}
  351.     foreach f [cdr [lreplace $lines end end]] {
  352.         set nm [lindex $f end]
  353.         if {[string length $nm]} {
  354.             if {[string match "d*" $f]} {
  355.                 lappend files "$nm/"
  356.             } else {
  357.                 lappend files $nm
  358.             }
  359.         }
  360.     }
  361.     return $files
  362. }
  363.  
  364.  
  365. proc ftpBrowse {host dir user password {fname {}}} {
  366.     global PREFS fetched lastFtpDir recentMounts savedMounts useCache
  367.  
  368.     watchCursor
  369.     if {![string length $password]} {
  370.         set password [prompt "Password:" ""]
  371.     }
  372.  
  373.     if {![file exists "$PREFS:ftptmp"]} {
  374.         mkdir "$PREFS:ftptmp"
  375.     }
  376.     if {$dir == {-}} {
  377.         if {![info exists lastFtpDir] || ![string length $lastFtpDir]} {set lastFtpDir ""}
  378.         set dir [prompt "'$host' dir:" $lastFtpDir]
  379.     }
  380.     set dir [string trimright $dir {/}]
  381.     set lastFtpDir $dir
  382.  
  383.     set num 0
  384.     for {set i [expr [string length $dir] - 1]} {$i >= 0} {incr i -1} {
  385.         scan $dir "%c" char
  386.         incr num $char
  387.     }
  388.     
  389.     set nm "$PREFS:ftptmp:listing.$num"
  390.     
  391.     if {!$useCache || ![file exists $nm]} {
  392.         ftpList $nm $host $dir $user $password
  393.     }
  394.     if {[catch {processListing $nm} listing]} {
  395.         alertnote "Error fetching directory '$dir'"
  396.         error "Error fetching directory '$dir'"
  397.     }
  398.     set files [concat {..} $listing]
  399.     if {$fname != ""} {
  400.         set file [listpick -L $fname -p "$dir/" $files]
  401.     } else {
  402.         set file [listpick -p "$dir/" $files]
  403.     }
  404.     
  405.     if {$file == {..}} {
  406.         if {[regexp {((/|\w)+)/\w+} $dir dummy sub]} {
  407.             return [ftpBrowse $host $sub $user $password]
  408.         } else {
  409.             return [ftpBrowse $host "" $user $password]
  410.         }
  411.     }
  412.  
  413.     if {[string match {*/} $file]} {
  414.         if {[string length $dir]} {
  415.             return [ftpBrowse $host [string trimright "$dir/$file" {/}] $user $password]
  416.         } else {
  417.             return [ftpBrowse $host [string trimright "$file" {/}] $user $password]
  418.         }
  419.     }
  420.  
  421.     set entry [list $host $dir $user $password]
  422.     set new 1
  423.     foreach name [array names savedMounts] {
  424.         if {([car $savedMounts($name)] == [car $entry]) && ([cadr $savedMounts($name)] == [cadr $entry])} {
  425.             set new 0
  426.             break;
  427.         }
  428.     }
  429.     if $new {
  430.         set recentMounts($dir) $entry
  431.         rebuildFtpMenu
  432.     }
  433.     
  434.     set nm "$PREFS:ftptmp:$file"
  435.     if {!$useCache || ![file exists $nm]} {
  436.         if {[string length $dir]} {
  437.             ftpFetch $nm $host "$dir/$file" $user $password
  438.         } else {
  439.             ftpFetch $nm $host "$file" $user $password
  440.         }
  441.     }
  442.     edit -w $nm
  443.     set fetched($nm) [list $host $dir $user $password]
  444. }
  445.